Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/Libraries/Bitmap Libraries 2.0/Lisp Interface/Library Folder Stuff/BitMaps.lisp

Text File | 1996-03-09 | 13.5 KB | 402 lines | [TEXT/CCL2]

;;-*- Mode: Lisp; Package: (BITMAPS) -*-
;;
;; File BitMap.lisp Copyright (C) 1996 by John R. Montbriand.
;; All Rights Reserved.
;;
;;  Copyright (C) 1994, 1996 by John Montbriand.  All Rights Reserved.
;;
;;  Distribute freely in areas where the laws of copyright apply.
;;
;;  Use at your own risk.
;;
;;  Do not distribute modified copies.
;;
;;  These various BitMap libraries are for free!
;;
;;  See the file BitMap.txt for details.
;;
;; Macintosh Common Lisp Foreign Function Interfaces to the BitMap Libraries

;; Before trying to use this file, you should put both
;; this file and the file BitMapsLib.o into the Library
;; folder inside of the MCL directory.


(unless (find-package "BITMAPS") (defpackage "BITMAPS"))

(in-package :bitmaps)

(export '(new-bitmap kill-bitmap duplicate-bitmap rotate-bitmap-right
               rotate-bitmap-left flip-bitmap-vertically flip-bitmap-horizontally
               rotate-bitmap paint-bucket-bitmap lasso-bitmap trace-bitmap-edges
               equal-bitmaps picture-to-bitmap bitmap-to-picture plot-bitmap
               and-bitmaps or-bitmaps xor-bitmaps complement-bitmap
               test-bitmap-pixel set-bitmap-pixel clear-bitmap-pixel
               toggle-bitmap-pixel string-to-bitmap with-focused-bitmap
               get-bitmap-width get-bitmap-height))


(require :ff)


;; BitMapLib.o contains a compiled version of the BitMap.c file
;; all set for loading into mcl
(ff-load "ccl:library;BitMapsLib.o" :ffenv-name 'bits)



(deffcfun (new-bitmap "NewBitMap")
   ((integer :word) (integer :word)) :ptr)
(setf (documentation 'new-bitmap 'function)
         "(new-bitmap width height) -> a bitmap
    parameters: (width, height)
    result: a new bitmap (null on error)
new-bitmap returns a new empty bitmap with the
specified width and height.")



(deffcfun (low-kill-bitmap "KillBitMap")
   ((macptr :ptr)) :novalue)
(defun kill-bitmap (badbits &rest other-bad-bits)
   (progn
      (low-kill-bitmap badbits)
      (unless (null other-bad-bits)
         (dolist (x other-bad-bits)
            (low-kill-bitmap x)))))
(setf (documentation 'kill-bitmap 'function)
      "(kill-bitmap bitmap &rest other-bitmaps)
    parameters: one or more bitmaps
    result: none
kill-bitmap disposes of one of more bitmaps created by
new-bitmap, duplicate-bitmap, rotate-bitmap-right, rotate-bitmap-left,
flip-bitmap-vertically, flip-bitmap-horizontally, rotate-bitmap,
paint-bucket-bitmap, lasso-bitmap, trace-bitmap-edges,
picture-to-bitmap, and-bitmaps, or-bitmaps, xor-bitmaps,
complement-bitmap, or string-to-bitmap.  It's your general
all purpose bitmap disposal function.")



(deffcfun (duplicate-bitmap "DuplicateBitMap")
   ((macptr :ptr)) :ptr)
(setf (documentation 'duplicate-bitmap 'function)
      "(duplicate-bitmap bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
duplicate-bitmap creates an exact duplicate of the bitmap
argument.  The resulting bitmap will contain the same image
and will have the same dimensions.")



(deffcfun (rotate-bitmap-right "RotateRight")
   ((macptr :ptr)) :ptr)
(setf (documentation 'rotate-bitmap-right 'function)
      "(rotate-bitmap-right bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
rotate-bitmap-right returns a new bitmap containing the
same image as the parameter rotated 90 degrees to the right.")



(deffcfun (rotate-bitmap-left "RotateLeft")
   ((macptr :ptr)) :ptr)
(setf (documentation 'rotate-bitmap-left 'function)
      "(rotate-bitmap-left bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
rotate-bitmap-right returns a new bitmap containing the
same image as the parameter rotated 90 degrees to the left")



(deffcfun (flip-bitmap-vertically "FlipVertical")
   ((macptr :ptr)) :ptr)
(setf (documentation 'flip-bitmap-vertically 'function)
      "(flip-bitmap-vertically bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
flip-bitmap-vertically returns a new bitmap containing the
same image as the parameter flipped upside down")



(deffcfun (flip-bitmap-horizontally "FlipHorizontal")
   ((macptr :ptr)) :ptr)
(setf (documentation 'flip-bitmap-horizontally 'function)
      "(flip-bitmap-horizontally bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
flip-bitmap-horizontally returns a new bitmap containing the
same image as the parameter flipped horizontally.")



(deffcfun (rotate-bitmap "iRotateBitMap")
   ((macptr :ptr) (integer :word) (integer :word) (integer :word)) :ptr)
(setf (documentation 'rotate-bitmap 'function)
      "(rotate-bitmap bitmap h-center v-center angle) -> a bitmap
    parameters: a bitmap, horizontal and vertical center of rotation, and an angle
    result: another bitmap
rotate-bitmap returns a new bitmap containing the image from the
parameter bitmap rotated angle degrees about the specified center
of rotation.")



(deffcfun (paint-bucket-bitmap "PaintBucketBitMap")
   ((macptr :ptr) (integer :word) (integer :word)) :ptr)
(setf (documentation 'paint-bucket-bitmap 'function)
      "(paint-bucket-bitmap bitmap h v) -> a bitmap
    parameters: a bitmap, horizontal and vertical starting point
    result: another bitmap
paint-bucket-bitmap returns a new bitmap containing containing
a mask calculated using the SeedFill routine.")



(deffcfun (lasso-bitmap "LassoBitMap")
   ((macptr :ptr)) :ptr)
(setf (documentation 'lasso-bitmap 'function)
      "(lasso-bitmap bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
lasso-bitmap returns a new bitmap containing containing
a mask calculated using the CalcMask routine.")



(deffcfun (trace-bitmap-edges "TraceBitMap")
   ((macptr :ptr)) :ptr)
(setf (documentation 'trace-bitmap-edges 'function)
      "(trace-bitmap-edges bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
trace-bitmap-edges returns a new bitmap containing containing
the image from the original bitmap with its edges traced.")



(deffcfun (low-equal-bitmaps "EqualBitMaps")
   ((macptr :ptr) (macptr :ptr)) :char)

(defun equal-bitmaps (bitmap-a bitmap-b)
"(equal-bitmaps bitmap-a bitmap-b) -> T or NIL
    parameters: two bitmaps
    result: zero or one
equal-bitmaps returns T if the two bitmaps are equal (they have
the same dimensions and they contain the same image) or NIL if
they are not equal."
   (eql 1 (logand (char-code (low-equal-bitmaps bitmap-a bitmap-b)) #x000000FF)))



(deffcfun (picture-to-bitmap "PICTToBitMap")
   ((macptr :ptr)) :ptr)
(setf (documentation 'picture-to-bitmap 'function)
"(picture-to-bitmap bitmap) -> a bitmap
    parameters: a bitmap
    result: a handle to a macintosh picture
picture-to-bitmap returns a returns a bitmap containing
a black and white representation of the image drawn by
the picture parameter.")



(deffcfun (bitmap-to-picture "BitMapToPICT")
   ((macptr :ptr)) :ptr)
(setf (documentation 'bitmap-to-picture 'function)
"(bitmap-to-picture bitmap) -> a picture handle
    parameters: a picture handle
    result: a bitmap
bitmap-to-picture returns a picture handle that will
draw the image stored in the bitmap.")



(deffcfun (plot-bitmap "PlotBitMap")
   ((macptr :ptr) (integer :word) (integer :word) (integer :word)) :novalue)
(setf (documentation 'plot-bitmap 'function)
"(plot-bitmap bitmap hpos vpos mode)
    parameters: a bitmap, the horizontal and vertical position, and the drawing mode
    result: a bitmap
plot-bitmap draws the bitmap parameter to the current port at the
indicated position using the specified drawing mode.  mode can be one
of:  #$srcCopy #$srcOr #$srcXor #$srcBic #$notSrcCopy
    #$notSrcOr #$notSrcXor #$notSrcBic #$patCopy #$patOr #$patXor
    #$patBic #$notPatCopy #$notPatOr #$notPatXor #$notPatBic")



(deffcfun (and-bitmaps "BitMapAND")
   ((macptr :ptr) (macptr :ptr)) :ptr)
(setf (documentation 'and-bitmaps 'function)
"(and-bitmaps bitmap-a bitmap-b) -> a bitmap
    parameters: two bitmaps with identical dimensions
    result: a bitmap
and-bitmaps returns a new bitmap with the same dimensions
as the two parameter bitmaps.  the raster data in the resulting
bitmap will be the result of logically and-ing together the raster
data from the two parameter bitmaps.")



(deffcfun (or-bitmaps "BitMapOR")
   ((macptr :ptr) (macptr :ptr)) :ptr)
(setf (documentation 'or-bitmaps 'function)
"(or-bitmaps bitmap-a bitmap-b) -> a bitmap
    parameters: two bitmaps with identical dimensions
    result: a bitmap
or-bitmaps returns a new bitmap with the same dimensions
as the two parameter bitmaps.  the raster data in the resulting
bitmap will be the result of logically or-ing together the raster
data from the two parameter bitmaps.")



(deffcfun (xor-bitmaps "BitMapXOR")
   ((macptr :ptr) (macptr :ptr)) :ptr)
(setf (documentation 'xor-bitmaps 'function)
"(xor-bitmaps bitmap-a bitmap-b) -> a bitmap
    parameters: two bitmaps with identical dimensions
    result: a bitmap
xor-bitmaps returns a new bitmap with the same dimensions
as the two parameter bitmaps.  the raster data in the resulting
bitmap will be the result of logically xor-ing together the raster
data from the two parameter bitmaps.")



(deffcfun (complement-bitmap "BitMapNOT")
   ((macptr :ptr)) :ptr)
(setf (documentation 'complement-bitmap 'function)
"(complement-bitmap bitmap) -> a bitmap
    parameters: a bitmap
    result: another bitmap
complement-bitmap returns a new bitmap with the same dimensions
as the parameter bitmap.  the raster data in the resulting
bitmap will be the result of logically complementing the
raster data from the parameter bitmap.")



(deffcfun (low-test-bitmap-pixel "BitMapTest")
   ((macptr :ptr) (integer :word) (integer :word)) :char)

(defun test-bitmap-pixel (bits x y)
"(test-bitmap-pixel bitmap x y) -> T or NIL
    parameters: a bitmap and a horizontal and vertical position
    result: T or NIL
test-bitmap-pixel returns T if the specified pixel
at location (x,y) is equal to one.  Otherwise the function
returns NIL"
   (eql 1 (logand (char-code (low-test-bitmap-pixel bits x y)) #x000000FF)))



(deffcfun (set-bitmap-pixel "BitMapSet")
   ((macptr :ptr) (integer :word) (integer :word)) :novalue)
(setf (documentation 'set-bitmap-pixel 'function)
"(set-bitmap-pixel bitmap hpos vpos)
    parameters: a bitmap and a horizontal and vertical location
    result: another bitmap
set-bitmap-pixel sets the indicated pixel in the bitmap's raster
image to the value one. ")



(deffcfun (clear-bitmap-pixel "BitMapClear")
   ((macptr :ptr) (integer :word) (integer :word)) :novalue)
(setf (documentation 'clear-bitmap-pixel 'function)
"(clear-bitmap-pixel bitmap hpos vpos)
    parameters: a bitmap and a horizontal and vertical location
    result: another bitmap
set-bitmap-pixel sets the indicated pixel in the bitmap's raster
image to the value zero. ")


(deffcfun (low-toggle-bitmap-pixel "BitMapToggle")
   ((macptr :ptr) (integer :word) (integer :word)) :char)

(defun toggle-bitmap-pixel (bits x y)
"(toggle-bitmap-pixel bitmap x y) -> T or NIL
    parameters: a bitmap and a horizontal and vertical position
    result: T or NIL
toggle-bitmap-pixel toggles a pixel in in the bitmap at the indicated
position and returns T or false indicating the state of the pixel after
the toggle. "
   (eql 1 (logand (char-code (low-toggle-bitmap-pixel bits x y)) #x000000FF)))



(deffcfun (low-string-to-bitmap "StringToBitMap")
   ((integer :word) (integer :word) (integer :word) (string :pstring)) :ptr)

(defun string-to-bitmap (the-string &optional the-font-spec)
"(string-to-bitmap the-string &optional the-font-spec) -> a bitmap
    parameters: a string and an optional font spec
    result: a bitmap
string-to-bitmap returns a bitmap sized appropriately to contain
the string parameter.  if the font spec is omitted, the system font
is used. "
   (if (null the-font-spec)
      (low-string-to-bitmap 0 12 0 the-string)    ; use 12 point system font
      (multiple-value-bind (ff ms) (font-codes the-font-spec)
          (low-string-to-bitmap
            (ash (logand ff #xFFFF0000) -16)   ; the font number
            (logand ms #x0000FFFF)             ; the font size
            (ash (logand ff #x0000FF00) -8)    ; the text face
            the-string))))



(defmacro with-focused-bitmap ((the-bitmap) &body body)
"(with-focused-bitmap bitmap {form}*) -> bitmap
    parameters: a bitmap and some forms
    result: the bitmap
sets up the current drawing enviroment so that all drawing commands
go into the bitmap and executes the forms.  Before exit, the original
grafport is restored. "
   `(without-interrupts
      (rlet ((myport :GrafPort) (current-port :GrafPtr))
         (require-trap #_GetPort current-port)
         (require-trap #_OpenPort myport)
         (require-trap #_SetPortBits ,the-bitmap)
         (require-trap #_PortSize
                               (rref ,the-bitmap bitmap.bounds.right)
                               (rref ,the-bitmap bitmap.bounds.bottom))
         (unwind-protect
            (progn ,@body)
            (progn
               (require-trap #_SetPort (%get-ptr current-port))
               (require-trap #_ClosePort myport)))
         ,the-bitmap)))



(defun get-bitmap-width (the-bitmap)
"(get-bitmap-width bitmap) -> the width
    parameters: a bitmap
    result: a number
get-bitmap-width returns a number representing the total
width of the bitmap. "
   (- (rref the-bitmap bitmap.bounds.right) (rref the-bitmap bitmap.bounds.left)))



(defun get-bitmap-height (the-bitmap)
"(get-bitmap-height bitmap) -> the height
    parameters: a bitmap
    result: a number
get-bitmap-height returns a number representing the total
height of the bitmap. "
   (- (rref the-bitmap bitmap.bounds.bottom) (rref the-bitmap bitmap.bounds.top)))


;; end of file BitMaps.lisp